home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 / Ham Radio 2000.iso / ham2000 / packet / terminal / top_152 / src152.exe / rar / TOPQTH.PAS < prev    next >
Pascal/Delphi Source File  |  1995-05-16  |  13KB  |  372 lines
  1. {┌─────────────────────────────────────────────────────────────────────────┐}
  2. {│                                                                         │}
  3. {│                              T. O. P.                                   │}
  4. {│                                                                         │}
  5. {│                        (T)he  (O)ther  (P)acket                         │}
  6. {│                                                                         │}
  7. {│ T O P Q T H . P A S                                                     │}
  8. {│                                                                         │}
  9. {│                                                                         │}
  10. {│ QTH-Kennerberechnung nach Routinen von DL5FBD (QTHBER V2.2)             │}
  11. {└─────────────────────────────────────────────────────────────────────────┘}
  12.  
  13.  
  14.  
  15. (***********************************************************)
  16. (* Procedure Entfernung_Richtung                           *)
  17. (* Die Prozedur dient zur Berechnung von Entfernung und    *)
  18. (* Richtung bei gegebenen geografischen Koordinaten im     *)
  19. (* Gradmass.                                               *)
  20. (* Ergebnis sind Entfernung in Kilometern und Richtung in  *)
  21. (* Grad von QTH1 nach QTH2.                                *)
  22. (* O1,N1 Oestliche Laenge,Noerdliche Breite von QTH1       *)
  23. (* O2,N2 Oestliche Laenge,Noerdliche Breite von QTH2       *)
  24. (***********************************************************)
  25.  
  26. Procedure Entfernung_Richtung (O1,N1,O2,N2 : REAL; Var Entfernung,Richtung : REAL);
  27. Const PI = 3.1415926;
  28. Var   EW,RV : REAL;
  29.  
  30.   Function GSIN(WINKEL : REAL) : REAL;
  31.   Begin
  32.     GSIN := SIN(Winkel*PI/180);
  33.   End;
  34.  
  35.   Function GCOS(WINKEL : REAL) : REAL;
  36.   Begin
  37.     GCOS:=COS(Winkel*PI/180);
  38.   End;
  39.  
  40.   Function ARCGCOS(COSINUS : REAL) : REAL;
  41.   Var ARCBOG : REAL;
  42.   Begin
  43.     if COSINUS >= 1 then ARCGCOS := 0 else
  44.       if COSINUS <= -1 then ARCGCOS := 180 else
  45.         begin
  46.           ARCBOG  := PI/2-ARCTAN(COSINUS/(SQRT(1-SQR(COSINUS))));
  47.           ARCGCOS := ARCBOG*180/PI;
  48.         end;
  49.   End;
  50.  
  51.  
  52. Begin
  53.   EW := arcgcos(gsin(n1)*gsin(n2)+gcos(n1)*gcos(n2)*gcos(o2-o1));
  54.   Entfernung := 40009/360*EW;
  55.  
  56.   RV := arcgcos((gsin(n2)-gsin(n1)*gcos(ew))/(gcos(n1)*gsin(ew)));
  57.   if gsin(o2-o1) >= 0  then Richtung := RV;
  58.   if gsin(o2-o1) <  0  then Richtung := 360-RV;
  59. End;
  60.  
  61.  
  62. (***********************************************************)
  63. (* Procedure NEU_IN_WINKEL                                 *)
  64. (* Diese Procedure dient zum Umwandeln eines neuen QTH-    *)
  65. (* kenners in geografische Laenge und Breite               *)
  66. (* I        Indexvariable fuer Feldzuweisung               *)
  67. (* OESLAE   Oestliche Laenge als Gleitkommawinkel          *)
  68. (* NOEBRE   Noerdliche Breite als Gleitkommawinkel         *)
  69. (* QTHKENN  QTH-Kenner als STRING                          *)
  70. (* WIINFO[6] Feld der QTH-Kennerindexziffern               *)
  71. (* ASCKOR[6] Hilfsfeld zur ASCII-Indexziffernumrechnung    *)
  72. (* Maske [6] Hilfsfeld zur Grossschrifteinstellung         *)
  73. (***********************************************************)
  74.  
  75. Procedure NEU_IN_WINKEL(QTHKENN :STR20; Var OESLAE,NOEBRE : REAL);
  76. Const   ASCKOR : Array [1..6] of Byte = (065,065,048,048,065,065);
  77.         MASKE  : Array [1..6] of Byte = (223,223,255,255,223,223);
  78.  
  79. Var i      : Byte;
  80.     WIINFO : Array [1..6] of Byte;
  81.  
  82. Begin
  83.   for i := 1 to 6 do WIINFO[i]:=(ORD(qthkenn[i]) AND MASKE[i])-ASCKOR[i];
  84.  
  85.   OESLAE := -180 + WIINFO[1] * 20 + WIINFO[3] * 2 + WIINFO[5]/12+1/24;
  86.   NOEBRE :=  -90 + WIINFO[2] * 10 + WIINFO[4] * 1 + WIINFO[6]/24+1/48;
  87. End;
  88.  
  89.  
  90.  
  91. (***********************************************************)
  92. (* Procedure GRAD_UMW                                      *)
  93. (* Diese Procedure wandelt eine als String uebergebene     *)
  94. (* geografische Koordinate im Format +GGG:MM:SS/-GG:MM:SS  *)
  95. (* mit Unterlaengen +GG:MM und -GG in die entsprechenden   *)
  96. (* Gleitkommawinkel um.  (Oestl. Laenge/Noerd. Breite)     *)
  97. (* Uebergeben wird der Koordinatenstr. und zurueck werden  *)
  98. (* die Gleitkommawinkel und eine Statusvariable uebergeben *)
  99. (* Ist diese False so ist ein Formatfehler entdeckt worden *)
  100. (* und die uebergebenen Winkelparameter undefiniert.       *)
  101. (* QTHKENN     Koordinatenstring                           *)
  102. (* OESLAE      Oestliche Laenge als REAL-Zahl              *)
  103. (* NOEBRE      Noerdliche Breite als REAL-Zahl             *)
  104. (* STATUS      TRUE Umwandlung erfolgreich vorgenommen     *)
  105. (*             FALSE Formatfehler entdeckt oder Bereichs-  *)
  106. (*                   fehler der Koordinatenwinkel          *)
  107. (* MENGE       Definition des Stringmengentyps             *)
  108. (* REFERENZ    Gueltige Elementemenge von QTHKENN          *)
  109. (* RASTER      Feld der gueltigen Formatraster von QTHKENN *)
  110. (* I           Index fuer Feldzugriffe                     *)
  111. (* P           Position des Trennzeichens '/' in QTHKENN   *)
  112. (*             und Kontrollvariable fuer VAL-Funktion      *)
  113. (* OES,NOE     String der oestlichen Laenge,noerdl. Breite *)
  114. (*             zur Umwandlung in den Gleitkommawinkel      *)
  115. (* VERGLEICH   Strukturabbild von QTHKENN zur Format-      *)
  116. (*             pruefung des Koordinatenstrings             *)
  117. (* LAENGE      Laenge von QTHKENN fuer Abfrageschleifen    *)
  118. (***********************************************************)
  119.  
  120. Procedure GRAD_UMW (QTHKENN          :STRING;
  121.                    VAR OESLAE,NOEBRE :REAL;
  122.                    VAR STATUS        :BOOLEAN);
  123.  
  124.   (***********************************************************)
  125.   (* FUNCTION GMS_UMW                                        *)
  126.   (* Die Funktion dient zur Umwandlung des Laengen und       *)
  127.   (* Breitengradstring in den entsprechenden Gleitkommawinkel*)
  128.   (* GMS      Stringteil mit Winkelinformation +GG:MM:SS     *)
  129.   (* UMWAND   Gleitkommawinkel                               *)
  130.   (* REST     Teilstring fuer Entnahme der GG,MM,SS-Info     *)
  131.   (* POSI     Position des Trennzeichens DP in REST         *)
  132.   (* VORZEI   Vorzeichenfaktor des Winkels +1 oder -1        *)
  133.   (* I        Potenz des Minuten und Sekundenfaktors zur     *)
  134.   (*          BASIS 60 fuer Gleitkommawinkelberechnung       *)
  135.   (* D        Fehlerposition fuer VAL-Procedure              *)
  136.   (* Teil     Enthaelt Ziffernfaktor fuer Grad,Min.,Sekunden *)
  137.   (* Summe    Teil- und Endsumme des Gleitkommawinkels       *)
  138.   (***********************************************************)
  139.  
  140.   Function GMS_UMW (GMS : Str20) : Real;
  141.  
  142.   Var REST   : STRING;
  143.       POSI   : BYTE;
  144.       VORZEI : ShortInt;
  145.       I      : BYTE;
  146.       D      : INTEGER;
  147.       Teil   : REAL;
  148.       SUMME  : REAL;
  149.  
  150.   BEGIN
  151.     I := 0;
  152.     SUMME := 0;
  153.     REST := GMS;
  154.     IF GMS[1]='-' then VORZEI := -1     
  155.                   else VORZEI := 1;     
  156.  
  157.     Repeat
  158.       Val(REST,TEIL,D);
  159.       IF D <> 0 then Val((COPY(REST,1,D-1)),TEIL,D);
  160.  
  161.       IF i = 0 then SUMME := TEIL
  162.                else SUMME := SUMME+VORZEI*TEIL/(EXP(LN(60)*i));
  163.       inc(i);
  164.  
  165.       POSI := pos(DP,REST);
  166.       REST := copy(REST,POSI+1,(LENGTH(REST)-POSI));
  167.     Until POSI = 0;
  168.     GMS_UMW := SUMME
  169.   End;
  170.  
  171.  
  172. Type  MENGE = Set of Char;
  173. Const REFERENZ : MENGE = ['0'..'9','+','-','/',DP,Pkt ];
  174.  
  175.       RASTER   : Array [1..12] of string
  176.  
  177.                 = ('VZ:Z:Z/VZ:Z:Z' , 'VZ:Z:Z/VZ:Z' , 'VZ:Z:Z/VZ' ,
  178.                      'VZ:Z/VZ:Z:Z' ,   'VZ:Z/VZ:Z' ,   'VZ:Z/VZ' ,
  179.                        'VZ/VZ:Z:Z' ,     'VZ/VZ:Z' ,     'VZ/VZ' ,
  180.                        'VZ.Z/VZ.Z' ,     'VZ/VZ.Z' ,   'VZ.Z/VZ');
  181.  
  182. Var   i         : Byte;
  183.       P         : Integer;
  184.       OES,NOE,
  185.       VERGLEICH : String;
  186.       LAENGE    : Byte;
  187.  
  188. Begin
  189. (* 1. Stringformat und Zeichengueltigkeit ueberpruefen     *)
  190. (* 2. Wenn gueltig in Gleitkommawinkel umwandeln und       *)
  191. (*    danach Gueltigkeitspruefung der Winkel vornehmen     *)
  192. (* 3. Wenn auch das in Ordnung Winkel und STATUS=TRUE      *)
  193.  
  194.   LAENGE := LENGTH(QTHKENN);
  195.   IF LAENGE <= 20 THEN
  196.     BEGIN
  197.  
  198.       (* Ueberpruefung von Format und Inhalt der Stringinformation *)
  199.  
  200.       VERGLEICH:='';
  201.       For I:=1 to LAENGE do
  202.         BEGIN
  203.           IF NOT(QTHKENN[I] IN REFERENZ)     THEN VERGLEICH:=VERGLEICH+'?'
  204.  
  205.           ELSE
  206.  
  207.             BEGIN
  208.               IF QTHKENN[I] IN ['+','-']     THEN VERGLEICH:=VERGLEICH+'V';
  209.               IF QTHKENN[I] ='/'             THEN VERGLEICH:=VERGLEICH+'/';
  210.               IF QTHKENN[I] =DP             THEN VERGLEICH:=VERGLEICH+DP ;
  211.               IF QTHKENN[I] =Pkt              THEN VERGLEICH:=VERGLEICH+Pkt ;
  212.               IF QTHKENN[I] IN ['0'..'9']    THEN
  213.                 BEGIN
  214.                   P:=LENGTH(VERGLEICH);
  215.                   IF VERGLEICH[P]<>'Z'      THEN VERGLEICH:=VERGLEICH+'Z';
  216.                 END;
  217.             END;
  218.  
  219.           END;
  220.  
  221.         (* Vorzeichenkennungen fuer Schreibfaule nachtragen *)
  222.  
  223.         IF VERGLEICH[1]='Z' THEN Insert('V',VERGLEICH,1);
  224.         P:=Pos('/',VERGLEICH)+1;
  225.         IF VERGLEICH[P]='Z' THEN Insert('V',VERGLEICH,P);
  226.  
  227.         (* Abfrage ob Vergleichsraster einem der gueltigen *)
  228.         (* Raster entspricht                               *)
  229.  
  230.             STATUS:=False;
  231.             FOR I:=1 to 12 do
  232.               STATUS:=STATUS OR (VERGLEICH = RASTER[I]);
  233.  
  234.     END
  235.  
  236.   ELSE STATUS := FALSE;
  237.  
  238.   (* 3. Zeichenkette in Koordinaten umwandeln wenn in Ordnung *)
  239.  
  240.   IF STATUS THEN
  241.   BEGIN
  242.     P:=POS('/',QTHKENN);
  243.     OES:=Copy(QTHKENN,1,P-1);
  244.     NOE:=Copy(QTHKENN,P+1,(LAENGE-P));
  245.     IF POS(Pkt ,OES) > 0 THEN VAL(OES,OESLAE,P)
  246.                         ELSE OESLAE := GMS_UMW(OES);
  247.     IF POS(Pkt ,NOE) > 0 THEN VAL(NOE,NOEBRE,P)
  248.                         ELSE NOEBRE := GMS_UMW(NOE);
  249.     IF ABS(NOEBRE) > 90  THEN STATUS  := False;
  250.     IF ABS(OESLAE) > 180 THEN STATUS := False;
  251.   END;
  252.  
  253. END;
  254.  
  255.  
  256.  
  257. Procedure QTH_ENTFG_RICHTG (QTH1,QTH2 : Str20;
  258.                             var ENTFG,
  259.                                 RICHTG : REAL;
  260.                             var STATUS : Boolean);
  261.  
  262. Var QTH        : Array[1..2] of Str20;
  263.     Winkel     : Array[1..4] OF Real;
  264.     I          : Byte;
  265.     K          : ShortInt;
  266.     LAENGE     : Byte;
  267.  
  268. BEGIN
  269.   QTH[1] := QTH1;
  270.   QTH[2] := QTH2;
  271.   K := -1;
  272.   STATUS := true;
  273.  
  274.   for i := 1 to 2 do if STATUS then
  275.   begin
  276.     LAENGE := length(QTH[I]);
  277.     K := K + 2;
  278.     if QTH[I][1] in ['+','-','0'..'9'] then
  279.     begin
  280.       GRAD_UMW(QTH[I],WINKEL[K],WINKEL[K+1],STATUS);
  281.     end else if LAENGE = 6 then
  282.     begin
  283.       NEU_IN_WINKEL(QTH[I],WINKEL[K],WINKEL[K+1]);
  284.     end else STATUS:=False;
  285.   end;
  286.  
  287.   if STATUS then
  288.     ENTFERNUNG_RICHTUNG(WINKEL[1],WINKEL[2],WINKEL[3],WINKEL[4],ENTFG,RICHTG);
  289. End;
  290.  
  291.  
  292. Procedure Compute_QTH (* Var Zeile : Str80 *);
  293. Const   DXC = 'DXC.DAT';
  294.  
  295. Var     f    : Text;
  296.         Flag : Boolean;
  297.         i,l,
  298.         AnzP : Byte;
  299.         Diff : ShortInt;
  300.         Entf,
  301.         Azim : Real;
  302.  
  303.         Dstr : String[3];
  304.         Sstr : String[6];
  305.         Tstr : String[8];
  306.         Fstr : String[13];
  307.         QTH  : String[20];
  308.         Nstr : String[40];
  309.         Lstr,
  310.         Rstr,
  311.         Hstr : String;
  312. Begin
  313.   Hstr := ParmStr(3,B1,Zeile);
  314.   if Hstr[length(Hstr)] = DP then
  315.   begin
  316.     Flag := false;
  317.     Assign(f,SysPfad + DXC);
  318.     if ResetTxt(f) = 0 then
  319.     begin
  320.       Readln(f,Hstr);
  321.       QTH := ParmStr(4,B1,Hstr);
  322.       Fstr := ParmStr(5,B1,Zeile);
  323.       l := 0;
  324.       While not Eof(f) do
  325.       begin
  326.         Readln(f,Hstr);
  327.         Lstr := ParmStr(1,DP,Hstr);
  328.         Sstr := ParmStr(1,Km,Lstr);
  329.         ParmAnz := AnzP;
  330.         i := 0;
  331.         Repeat
  332.           inc(i);
  333.           Sstr := ParmStr(i,Km,Lstr);
  334.           if (pos(Sstr,Fstr) = 1) and (ord(Sstr[0]) > l) then
  335.           begin
  336.             Flag := true;
  337.             l := ord(Sstr[0]);
  338.             Rstr := Hstr;
  339.           end;
  340.         Until i >= AnzP;
  341.       end;
  342.       FiResult := CloseTxt(f);
  343.  
  344.       if Flag then
  345.       begin
  346.         Lstr := ParmStr(1,DP,Rstr);
  347.         Zeile := EFillStr(27,B1,ParmStr(2,DP,Rstr));
  348.         Zeile := Zeile + 'Zone' + DP + SFillStr(3,B1,ParmStr(3,DP,Rstr)) + B2 + 'Dist' + DP;
  349.         Lstr := ParmStr(4,DP,Rstr);
  350.         Dstr := ParmStr(3,';',Lstr);
  351.         i := pos(Pkt,Dstr);
  352.         if i > 0 then Dstr := copy(Dstr,1,i-1);
  353.         Diff := ShortInt(str_int(Dstr));
  354.         Tstr := Uhrzeit;
  355.         Tstr := UtcZeit;
  356.         i := str_int(copy(Tstr,1,2));
  357.         i := i + 24 + Diff;
  358.         While i > 23 do i := i - 24;
  359.         Tstr := SFillStr(2,'0',int_str(i)) + DP + copy(Tstr,4,2);
  360.         QTH_ENTFG_RICHTG(QTH,ParmStr(2,';',Lstr) + '/' +
  361.                              ParmStr(1,';',Lstr),Entf,Azim,Flag);
  362.         if Flag then
  363.         begin
  364.           Zeile := Zeile + SFillStr(6,B1,int_str(Round(Entf))) + B1 + 'km' + B3 + 'Beam' + DP +
  365.                            SFillStr(4,B1,int_str(Round(Azim))) + '°' +
  366.                            B3 + '(' + Tstr + ')';
  367.         end;
  368.       end else Zeile := '';
  369.     end else WishDXC := false;
  370.   end else Zeile := '';
  371. End;
  372.